Shareware Grab Bag

home *** CD-ROM | disk | FTP | other *** search

/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / chasm.arc / CHASM.BAS (.txt) next >

Wrap

GW-BASIC | 1983-08-01 | 32.4 KB | 1,146 lines

10000 '============================== 10010 'PROGRAM CHASM Version 2.10 10020 'Begun 6/15/82 by Dave Whitman 10030 '============================== 10040 DEFINT A-Z 10050 MAXOBJ = 50: DIM OBJ(50) 10060 MAXSTK = 10: DIM PROCTYPE(10): STKTOP = 0 10070 NUMOP = 213 10080 DIM OPCODE$(213),OPVAL(213),SRCTYPE(213),DSTTYPE(213),OFLAG(213) 10090 PREDEF = 29: MAXSYM = 200 10100 DIM SYM$(200),VAL1(200),VAL2(29),SYMTYPE(200) 10110 ' 10120 'main program 10130 GOSUB 50000 'initialize 10140 CHAIN MERGE "chasm.ovl",10150,ALL,DELETE 50000-51660 'kill init section 10150 GOSUB 19500 'finish init 10160 GOSUB 10200 'pass 1: build sym table 10170 GOSUB 10420 'pass 2: obj code & listing 10180 GOSUB 19000 'clean up 10190 SYSTEM 10200 '=================== 10210 'SUBROUTINE PASSONE 10220 'Builds symbol table 10230 '=================== 10240 PASS = 1 10250 OPEN O$ AS #3 LEN=1: FIELD #3,1 AS BYTE$ 10260 LOCTR = 256 'room for PSP 10270 LINENUM = 0 10280 BASCODE = FALSE 10290 WHILE NOT EOF(1) 10300 'get line, init 10310 GOSUB 10630 10320 'parse 10330 GOSUB 10810 10340 'label? add to table 10350 IF LABEL$ <> "" THEN GOSUB 11580 10360 'op? decode, update loctr 10370 IF OP$ <> "" THEN GOSUB 12320 10380 'report 10390 GOSUB 19370 10400 WEND 10410 RETURN 10420 '============================ 10430 'SUBROUTINE PASSTWO 10440 'Generates obj code & listing 10450 '============================ 10460 GOSUB 18730 'pass2_init 10470 ' 10480 WHILE NOT EOF(1) 10490 'get line, init 10500 GOSUB 10630 10510 'parse 10520 GOSUB 10810 10530 'phase? 10540 IF LABEL$ <> "" THEN GOSUB 11780 10550 'update loctr, gen. obj. code 10560 IF OP$ <> "" THEN GOSUB 12320 10570 'output 10580 GOSUB 18140 10590 'report 10600 GOSUB 19370 10610 WEND 10620 RETURN 10630 '=========================== 10640 'SUBROUTINE GETLINE 10650 'Gets src line, expands tabs 10660 '& sets up for new iteration 10670 '=========================== 10680 LINE INPUT#1, INPLINE$ 10690 GOSUB 10750 'tabs 10700 LINENUM = LINENUM + 1 10710 NEEDOFFSET = NONE: DSFLAG = FALSE 10720 OBJLEN = 0 10730 RETURN 10740 'subroutine tabs 10750 I = INSTR(INPLINE$,CHR$(9)) 10760 WHILE I <> 0 10770 INPLINE$ = LEFT$(INPLINE$,I-1)+SPACE$(8-((I-1)MOD 8))+MID$(INPLINE$,I+1) 10780 I = INSTR(INPLINE$,CHR$(9)) 10790 WEND 10800 RETURN 10810 '================= 10820 'SUBROUTINE PARSE 10830 'Parses input line 10840 '================= 10850 LINEPTR = 1: LINEPTR2 = 1 10860 LABEL$ = "": OP$ = "": SOURCE$ = "": DEST$ = "" 10870 'mark end of code 10880 ENDPTR = INSTR(INPLINE$,";") - 1 10890 IF ENDPTR = -1 THEN ENDPTR = LEN(INPLINE$) 10900 'no code? (exit) 10910 IF ENDPTR = 0 THEN 11120 10920 'capitalize 10930 GOSUB 11140 10940 'label? 10950 IF INSTR(DELIM$,LEFT$(INPLINE$,1)) THEN 10980 10960 GOSUB 11270 'getfield 10970 LABEL$ = FLD$ 10980 'op-code 10990 GOSUB 11270 'getfield 11000 IF NOT FOUND THEN 11120 11010 OP$ = FLD$ 11020 'save ptr to start of operands 11030 OPDPTR = LINEPTR 11040 'dest operand? 11050 GOSUB 11270 'getfield 11060 IF NOT FOUND THEN 11120 11070 DEST$ = FLD$ 11080 'src operand? 11090 GOSUB 11270 'getfield 11100 IF NOT FOUND THEN 11120 11110 SOURCE$ = FLD$ 11120 RETURN 11130 ' 11140 'subroutine caps 11150 'Scans inpline$ up to ";" capitalizing. Skips strings 11160 FOR I = 1 TO ENDPTR 11170 C$ = MID$(INPLINE$,I,1) 11180 'skip strings 11190 IF C$ <> "'" THEN 11230 11200 STRGEND = INSTR(I+1,INPLINE$,C$) 11210 IF STRGEND > 0 THEN I = STRGEND: GOTO 11240 11220 'convert 11230 IF ASC(C$) => 97 AND ASC(C$) <= 122 THEN C$ = CHR$(ASC(C$) - 32): MID$(INPLINE$,I,1) = C$ 11240 NEXT I 11250 RETURN 11260 '=================================================== 11270 'SUBROUTINE GETFIELD 11280 'Starting at lineptr, trys to get next field in FLD$ 11290 'Sets found if sucessful. Moves lineptr past field 11300 '==================================================== 11310 'find next non-delim or run off end 11320 WHILE LINEPTR <= ENDPTR 11330 IF INSTR(DELIM$,MID$(INPLINE$,LINEPTR,1)) = 0 THEN 11360 11340 LINEPTR = LINEPTR + 1 11350 WEND 11360 'past end? 11370 IF LINEPTR <= ENDPTR THEN 11400 11380 FOUND = FALSE 11390 RETURN 11400 'strings end with ' 11410 IF MID$(INPLINE$,LINEPTR,1) <> "'" THEN 11460 11420 STRGEND = INSTR(LINEPTR+1,INPLINE$,"'") 11430 IF STRGEND = 0 THEN 11460 11440 LINEPTR2 = STRGEND + 1 11450 GOTO 11520 11460 'else, find delim or go 1 past end 11470 LINEPTR2 = LINEPTR 11480 WHILE LINEPTR2 <= ENDPTR 11490 IF INSTR(DELIM$,MID$(INPLINE$,LINEPTR2,1)) > 0 THEN 11520 11500 LINEPTR2 = LINEPTR2 + 1 11510 WEND 11520 'copy field 11530 FLD$ = MID$(INPLINE$,LINEPTR,LINEPTR2-LINEPTR) 11540 'lineptr past field, set found 11550 LINEPTR = LINEPTR2 11560 FOUND = TRUE 11570 RETURN 11580 '============================ 11590 'SUBROUTINE NEWENTRY 11600 'Adds new symbol to sym table 11610 '============================ 11620 'already there? 11630 TARGET$ = LABEL$ 11640 GOSUB 11890 'operand_lookup 11650 IF NOT FOUND THEN 11680 11660 MSG$ = "Duplicate definition of "+LABEL$+" ": GOSUB 18920 11670 RETURN 11680 'table full? 11690 IF NUMSYM < MAXSYM THEN 11720 11700 MSG$ = "Too many user symbols": GOSUB 18920 11710 RETURN 11720 'else make new entry 11730 NUMSYM = NUMSYM + 1 11740 SYM$(NUMSYM) = LABEL$ 11750 VAL1(NUMSYM) = LOCTR 11760 SYMTYPE(NUMSYM) = NEAR 11770 RETURN 11780 '============================= 11790 'SUBROUTINE CHECK_PHASE 11800 'Label value same both passes? 11810 '============================= 11820 IF OP$ = "EQU" THEN 11880 11830 TARGET$ = LABEL$ 11840 GOSUB 11890 'operand_lookup 11850 IF (SYMTYPE(TABLEPTR) AND (NEAR OR MEM)) = FALSE THEN 11880 11860 IF VAL1(TABLEPTR) = LOCTR THEN 11880 11870 MSG$ = "Phase Error": GOSUB 18920 11880 RETURN 11890 '=========================================== 11900 'SUBROUTINE OPERAND_LOOKUP 11910 'Trys to find TARGET$ in sym table. If there 11920 'sets FOUND true, & TABLEPTR to its position 11930 '=========================================== 11940 'scan table 11950 FOR TABLEPTR = 1 TO NUMSYM 11960 IF SYM$(TABLEPTR) = TARGET$ THEN 12010 11970 NEXT TABLEPTR 11980 'failure 11990 FOUND = FALSE 12000 RETURN 12010 'sucess 12020 FOUND = TRUE 12030 RETURN 12040 '================================================ 12050 'SUBROUTINE LOOKUP_OP 12060 'Given op-code in op$, & operand types in dtype & 12070 'stype, trys to find op in opcode table. If there 12080 'sets found true, & opptr to its position. 12090 '================================================ 12100 'binary search for good starting pt. 12110 MOVE = NUMOP: ST = MOVE/2 12120 WHILE MOVE >= 2 12130 MOVE = MOVE/2 12140 IF OP$ > OPCODE$(ST) THEN ST = ST + MOVE ELSE ST = ST - MOVE 12150 IF ST < 1 THEN ST = 1 12160 IF ST > NUMOP THEN ST = NUMOP 12170 WEND 12180 'scan to match all 3 fields 12190 FOR OPPTR = ST TO NUMOP 12200 IF OPCODE$(OPPTR) > OP$ THEN 12260 'failed 12210 IF OPCODE$(OPPTR) <> OP$ THEN 12250 12220 IF (SRCTYPE(OPPTR) AND STYPE) = FALSE THEN 12250 12230 IF (DSTTYPE(OPPTR) AND DTYPE) = FALSE THEN 12250 12240 GOTO 12290 'found! 12250 NEXT OPPTR 12260 'failure 12270 FOUND = FALSE 12280 RETURN 12290 'success 12300 FOUND = TRUE 12310 RETURN 12320 '============================== 12330 'SUBROUTINE UPDATE_LOCTR 12340 'Decodes op & advances loctr 12350 '2nd pass, generate obj code 12360 '============================== 12370 'set operand types & vals 12380 'dest 12390 TARGET$ = DEST$: GOSUB 12660 'type_operand 12400 DTYPE = TARGTYPE: DVAL1 = TARGVAL1: DVAL2 = TARGVAL2 12410 'src 12420 'special case: RET op 12430 IF OP$ = "RET" THEN STYPE = PROCTYPE(STKTOP): GOTO 12480 12440 'normal 12450 TARGET$ = SOURCE$: GOSUB 12660 'type_operand 12460 STYPE = TARGTYPE: SVAL1 = TARGVAL1: SVAL2 = TARGVAL2 12470 ' 12480 'find op in op table (not there: error) 12490 TARGET$ = OP$ 12500 GOSUB 12040 'lookup_op 12510 IF FOUND THEN 12610 12520 IF PASS = 1 THEN RETURN 12530 MSG$ = "Syntax Error: "+ OP$ + " " + STR$(DTYPE) + " " + STR$(STYPE) 12540 GOSUB 18920 12550 IF ((ACUM8 OR ACUM16 OR REG8 OR REG16 OR SEGR OR CS) AND (DTYPE OR STYPE)) THEN 12600 12560 IF (STYPE AND (NONE OR IMMED8 OR IMMED16)) = FALSE THEN 12600 12570 IF INSTR("BW",RIGHT$(OP$,1)) <> 0 THEN 12600 12580 DIAGFLAG = TRUE 12590 MSG$ = "Specify word or byte operation": GOSUB 18920 12600 RETURN 12610 FLAG = OFLAG(OPPTR) 12620 ' 12630 'branch to update loctr 12640 IF FLAG AND MACHOP THEN GOSUB 14830 ELSE GOSUB 15580 12650 RETURN 12660 '====================================== 12670 'SUBROUTINE TYPE_OPERAND 12680 'Sets TARGTYPE to TARGET$'s type. Sets 12690 'TARGVAL1 to its value. If a reg, sets 12700 'TARVAL2 to its val2. If offset appears 12710 'NEEDOFFSET & OFFSET are set. 12720 '====================================== 12730 'any operand? 12740 IF LEN(TARGET$) > 0 THEN 12770 12750 TARGTYPE = NONE 12760 RETURN 12770 'in sym table? 12780 GOSUB 11890 12790 IF NOT FOUND THEN 12830 12800 TARGTYPE = SYMTYPE(TABLEPTR): TARGVAL1 = VAL1(TABLEPTR) 12810 IF TABLEPTR <= PREDEF THEN TARGVAL2 = VAL2(TABLEPTR) 12820 RETURN 12830 'number? 12840 GOSUB 13230 12850 IF NOT FOUND THEN 12880 12860 TARGTYPE = NUMTYPE: TARGVAL1 = NUMVAL 12870 RETURN 12880 'mem ref? 12890 GOSUB 13630 12900 IF NOT FOUND THEN 12930 12910 TARGTYPE = MEM: TARVAL1 = MEMADDR 12920 RETURN 12930 'offset off register? 12940 GOSUB 13930 12950 IF NOT FOUND THEN 12990 12960 TARGTYPE = MEMREG: TARGVAL1 = REGVAL 12970 RETURN 12980 'offset? 12990 GOSUB 14490 13000 IF NOT FOUND THEN 13030 13010 TARGTYPE = OFFSETYPE: TARGVAL1 = OFFSETVAL 13020 RETURN 13030 'char? 13040 GOSUB 14720 13050 IF NOT FOUND THEN 13080 13060 TARGTYPE = IMMED8 OR IMMED16: TARGVAL1 = CHARVAL 13070 RETURN 13080 'string? 13090 IF LEFT$(TARGET$,1) <> "'" THEN 13120 13100 TARGTYPE = STRING 13110 RETURN 13120 'not found? assume label or mem (pass 2 error) 13130 IF PASS = 1 THEN 13210 13140 MSG$ = "Undefined Symbol "+TARGET$: GOSUB 18920 13150 'look like hex? 13160 IF RIGHT$(TARGET$,1) <> "H" OR LEN(TARGET$) > 5 THEN 13210 13170 FOR I = 1 TO LEN(TARGET$)-1 13180 IF INSTR("1234567890ABCDEF", MID$(TARGET$,I,1)) = 0 THEN 13210 13190 NEXT I 13200 MSG$ = "Add leading zero to hex constant":DIAGFLAG = TRUE: GOSUB 18920 13210 TARGTYPE = NEAR OR MEM 13220 RETURN 13230 '===================================== 13240 'SUBROUTINE TEST_NUMBER 13250 'Trys to interpret TARGET$ as a num 13260 'If sucessful, sets FOUND true, NUMVAL 13270 'to its value and NUMTYPE to its type 13280 '===================================== 13290 FOUND = FALSE 13300 IF INSTR("1234567890",LEFT$(TARGET$,1)) = 0 THEN RETURN 13310 TN$ = TARGET$ 'make copy 13320 IF LEFT$(TN$,1) = "0" THEN TN$ = RIGHT$(TN$,LEN(TN$)-1) 13330 ' 13340 'hex? 13350 IF (RIGHT$(TN$,1) <> "H") OR (LEN(TN$) > 5) THEN 13490 13360 'lop off H 13370 TN$ = LEFT$(TN$,LEN(TN$)-1) 13380 'non-hex digits? 13390 I = 1 13400 FOR I = 1 TO LEN(TN$) 13410 C$ = MID$(TN$,I,1) 13420 IF INSTR("0123456789ABCDEF",C$) = 0 THEN RETURN 13430 NEXT I 13440 'get value 13450 NUMVAL = VAL("&H"+TN$) 13460 'set type, return 13470 GOTO 13590 13480 ' 13490 'dec number? 13500 'non-dec digits? 13510 FOR I = 1 TO LEN(TN$) 13520 C$ = MID$(TN$,I,1) 13530 IF INSTR("0123456789-+",C$) = 0 THEN RETURN 13540 NEXT I 13550 'get value (overflow?) 13560 NVAL# = VAL(TN$) 13570 IF NVAL# < 32768 AND NVAL# > -32769 THEN NUMVAL = NVAL# ELSE RETURN 13580 ' 13590 'sucess exit 13600 FOUND = TRUE 13610 IF LEN(HEX$(NUMVAL)) < 3 THEN NUMTYPE = IMMED16 OR IMMED8 ELSE NUMTYPE = IMMED16 13620 RETURN 13630 '================================== 13640 'SUBROUTINE MEMREF 13650 'Trys to interpret target$ as a mem 13660 'ref. If so, sets FOUND true, & 13670 'MEMADDR to the address referenced. 13680 '================================== 13690 MR$ = TARGET$ 'save copy 13700 '[]? 13710 IF LEFT$(MR$,1) <> "[" OR RIGHT$(MR$,1) <> "]" THEN RETURN 13720 'strip [] 13730 TARGET$ = MID$(MR$,2,LEN(MR$)-2) 13740 'try to parse as addr 13750 'number? 13760 GOSUB 13230 13770 IF NOT FOUND THEN 13800 13780 MEMADDR = NUMVAL 13790 GOTO 13900 'exit 13800 'symbol? 13810 GOSUB 11890 13820 IF NOT FOUND THEN 13860 13830 IF (SYMTYPE(TABLEPTR) AND IMMED16) = FALSE THEN 13860 13840 MEMADDR = VAL1(TABLEPTR) 13850 GOTO 13900 'exit 13860 'failure 13870 FOUND = FALSE 13880 TARGET$ = MR$ 13890 RETURN 13900 'sucess 13910 TARGET$ = MR$ 13920 RETURN 13930 '======================================= 13940 'SUBROUTINE PARSE_DISP_OFF_REG 13950 'Trys to parse TARGET$ as offset off reg 13960 'If so, sets FOUND true, sets NEEDOFFSET 13970 'to offset's type, and OFFSET its value 13980 '======================================= 13990 PDOR$ = TARGET$ 'save copy 14000 ' 14010 'special case 14020 IF TARGET$ = "[BP]" THEN REGVAL = 6: NEEDOFFSET = IMMED8: OFFSET = 0: GOTO 14410 14030 ' 14040 'parse reg 14050 'set ptr to candidate 14060 PTR = INSTR(TARGET$,"[") 14070 IF PTR <= 1 THEN 14450 'no disp, exit 14080 'isolate candidate 14090 REG$ = RIGHT$(PDOR$,LEN(PDOR$)-PTR+1) 14100 'valid reg? 14110 IF REG$ = "[BP]" THEN REGVAL = 6: GOTO 14180 14120 TARGET$ = REG$ 14130 GOSUB 11890 'operand_lookup 14140 IF NOT FOUND OR SYMTYPE(TABLEPTR) <> MEMREG THEN 14450 14150 'save reg value 14160 REGVAL = VAL1(TABLEPTR) 14170 ' 14180 'now parse disp. 14190 'isolate candidate 14200 DISP$ = LEFT$(PDOR$,PTR-1) 14210 'valid disp? 14220 TARGET$ = DISP$ 14230 'might be symbol 14240 GOSUB 11890 14250 IF NOT FOUND THEN 14300 'not sym 14260 IF (SYMTYPE(TABLEPTR) AND (IMMED16 OR IMMED8)) = FALSE THEN 14300 14270 OFFSET = VAL1(TABLEPTR) 14280 NEEDOFFSET = SYMTYPE(TABLEPTR) 14290 GOTO 14410 14300 'or number 14310 GOSUB 13230 14320 IF NOT FOUND THEN 14360 14330 OFFSET = NUMVAL 14340 IF OFFSET > 127 OR OFFSET < -128 THEN NEEDOFFSET = IMMED16 ELSE NEEDOFFSET = IMMED8 14350 GOTO 14410 14360 'or offset 14370 GOSUB 14490 'offset 14380 IF NOT FOUND THEN 14450 14390 OFFSET = OFFSETVAL 14400 NEEDOFFSET = IMMED16 14410 'sucess 14420 TARGET$ = PDOR$ 14430 FOUND = TRUE 14440 RETURN 14450 'failure 14460 TARGET$ = PDOR$ 14470 FOUND = FALSE 14480 RETURN 14490 '====================================== 14500 'SUBROUTINE OFFSET 14510 'Trys to interpret TARGET$ as an offset 14520 'If sucessful, set FOUND, set OFFSETYPE 14530 'to immed16, TARGVAL1 to label's offset 14540 '====================================== 14550 OS$ = TARGET$ 14560 IF LEFT$(OS$,7) <> "OFFSET(" THEN FOUND = FALSE: RETURN 14570 IF PASS = 1 THEN 14680 14580 'isolate label 14590 TARGET$ = MID$(TARGET$,8,LEN(TARGET$)-8) 14600 'look it up 14610 GOSUB 11890 14620 IF FOUND AND (SYMTYPE(TABLEPTR) AND (MEM OR NEAR)) THEN 14660 14630 MSG$ = "Illegal or undefined argument for Offset": GOSUB 18920 14640 OFFSETVAL = 0 14650 GOTO 14680 14660 OFFSETVAL = VAL1(TABLEPTR) 14670 ' 14680 FOUND = TRUE 14690 OFFSETYPE = IMMED16 14700 TARGET$ = OS$ 14710 RETURN 14720 '============================= 14730 'SUBROUTINE CHAR 14740 'Trys to parse TARGET$ as char 14750 '============================= 14760 FOUND = FALSE 14770 IF LEN(TARGET$) <> 3 THEN RETURN 14780 IF LEFT$(TARGET$,1) <> "'" THEN RETURN 14790 IF RIGHT$(TARGET$,1) <> "'" THEN RETURN 14800 FOUND = TRUE 14810 CHARVAL = ASC(MID$(TARGET$,2,1)) 14820 RETURN 14830 '============================= 14840 'SUBROUTINE MACHOP 14850 'Updates loctr based on op len 14860 'On pass 2, generates obj. code 14870 '============================== 14880 GOSUB 15450 'op_type 14890 ' 14900 'opcode 14910 LOCTR = LOCTR + 1 14920 IF PASS = 2 THEN GOSUB 15640 'build_opcode 14930 ' 14940 '2nd op byte? 14950 IF (OPVAL(OPPTR) <> &HD5) AND (OPVAL(OPPTR) <> &HD4) THEN 14990 14960 LOCTR = LOCTR + 1 14970 IF PASS = 2 THEN OBJLEN = OBJLEN + 1: OBJ(OBJLEN) = &HA 14980 ' 14990 'room for m. byte disp. (must go here) 15000 IF NEEDOFFSET = NONE THEN 15030 15010 IF NEEDOFFSET AND IMMED8 THEN LOCTR = LOCTR+1: ELSE LOCTR = LOCTR+2 15020 ' 15030 'direct addr. mode byte? leave room for addr 15040 IF (FLAG AND (NEEDMODEBYTE OR NEEDEXT)) = FALSE THEN 15070 15050 IF (DTYPE OR STYPE) AND MEM THEN LOCTR = LOCTR + 2 15060 ' 15070 'ext. byte? 15080 IF (FLAG AND NEEDEXT) = FALSE THEN 15120 15090 LOCTR = LOCTR + 1 15100 IF PASS = 2 THEN GOSUB 15850 'build_ext 15110 ' 15120 'mode byte? 15130 IF (FLAG AND NEEDMODEBYTE) = FALSE THEN 15170 15140 LOCTR = LOCTR + 1 15150 IF PASS = 2 THEN GOSUB 15970 'build_modebyte 15160 ' 15170 '8 bit disp? 15180 IF (FLAG AND NEEDISP8) = FALSE THEN 15220 15190 LOCTR = LOCTR + 1 15200 IF PASS = 2 THEN GOSUB 16420 'build_disp8 15210 ' 15220 '16 bit disp? 15230 IF (FLAG AND NEEDISP16) = FALSE THEN 15270 15240 LOCTR = LOCTR + 2 15250 IF PASS = 2 THEN GOSUB 16590 'build_disp16 15260 ' 15270 'immed byte? 15280 IF (FLAG AND NEEDIMMED8) = FALSE THEN 15310 15290 LOCTR = LOCTR + 1 15300 IF PASS = 2 THEN GOSUB 16850 15310 IF WORD OR ((FLAG AND NEEDIMMED) = FALSE) THEN 15350 15320 LOCTR = LOCTR + 1 15330 IF PASS = 2 THEN GOSUB 16850 'build_immed8 15340 ' 15350 'immed word(s)? 15360 IF NOT(WORD) OR ((FLAG AND NEEDIMMED) = FALSE) THEN 15400 15370 IF DTYPE = IMMED16 THEN LOCTR = LOCTR + 4 ELSE LOCTR = LOCTR + 2 15380 IF PASS = 2 THEN GOSUB 16720 'build_immed16 15390 ' 15400 'mem addr? 15410 IF (FLAG AND NEEDMEM) = FALSE THEN 15440 15420 LOCTR = LOCTR + 2 15430 IF PASS = 2 THEN GOSUB 16960 'mem_addr 15440 RETURN 15450 '=============================== 15460 'SUBROUTINE OP_TYPE 15470 'Decides between word & byte ops 15480 '=============================== 15490 IF (DTYPE OR STYPE) AND (REG16 OR ACUM16 OR SEGR OR CS) THEN 15520 15500 IF (DTYPE OR STYPE) AND (REG8 OR ACUM8) THEN 15550 15510 IF RIGHT$(OP$,1) = "B" THEN 15550 15520 'word 15530 WORD = TRUE 15540 RETURN 15550 'byte 15560 WORD = FALSE 15570 RETURN 15580 '==================== 15590 'SUBROUTINE PSEUDO-OP 15600 '==================== 15610 ON OPVAL(OPPTR) GOSUB 17080,17210,17270,17670,17830,17930,18010,18060 15620 ' EQU ORG DB DS PROC ENDP BSAVE EJECT 15630 RETURN 15640 '======================= 15650 'SUBROUTINE BUILD_OPCODE 15660 'Builds opcode in OBJ 15670 '======================= 15680 OBJLEN = OBJLEN + 1 15690 OBJ(OBJLEN) = OPVAL(OPPTR) 15700 ' 15710 'reg field? 15720 IF (FLAG AND ADDREG) = FALSE THEN 15780 15730 'seg reg 15740 IF DTYPE AND (SEGR OR CS) THEN R = DVAL2: GOTO 15770 15750 'normal reg 15760 IF (FLAG AND DIRECTION) THEN R = SVAL2/8 ELSE R = DVAL2/8 15770 OBJ(OBJLEN) = OBJ(OBJLEN) + R 15780 'word bit? 15790 IF (FLAG AND AUTOW) = FALSE THEN 15810 15800 IF WORD THEN OBJ(OBJLEN) = OBJ(OBJLEN) + 1 15810 'count bit? 15820 IF (FLAG AND AUTOC) = FALSE THEN 15840 15830 IF STYPE AND CL THEN OBJ(OBJLEN) = OBJ(OBJLEN) + 2 15840 RETURN 15850 '=================================== 15860 'SUBROUTINE BUILD_EXTENSION_BYTE 15870 'Builds opcode ext byte. Ext val is 15880 'extracted from bits 3-5 of flag word 15890 '==================================== 15900 'get ext 15910 MASK = &H38 15920 EXT = FLAG AND MASK 15930 'define proper opd as ext & build 15940 IF FLAG AND DIRECTION THEN DVAL2 = EXT ELSE SVAL2 = EXT 15950 GOSUB 15970 'build_modebyte 15960 RETURN 15970 '====================================================== 15980 'SUBROUTINE BUILD_MODE_BYTE 15990 'Given direction flag, memreg values in dval1 & sval1 & 16000 'reg values in dval2 & sval2, builds an addressing mode 16010 'byte. If necessary, also builds displacement byte(s). 16020 '======================================================= 16030 OBJLEN = OBJLEN + 1 16040 'special case: direct mem. addressing? 16050 IF ((DTYPE OR STYPE) AND MEM) = FALSE THEN 16110 16060 IF DTYPE = MEM THEN M = SVAL2 ELSE M = DVAL2 16070 OBJ(OBJLEN) = 6 + M 16080 GOSUB 16960 'build_mem_addr 16090 RETURN 16100 'normal mode byte 16110 'opds in normal or reverse order? 16120 IF FLAG AND DIRECTION THEN M = SVAL1 + DVAL2 ELSE M = DVAL1 + SVAL2 16130 OBJ(OBJLEN) = M 16140 'offset byte(s)? 16150 IF NEEDOFFSET = NONE THEN 16310 16160 '8 bit disp. 16170 IF OFFSET > 127 OR OFFSET < -128 THEN 16240 16180 OBJ(OBJLEN) = OBJ(OBJLEN) + 64 'set mod field 16190 'crunch neg. offset to 8 bits 16200 IF OFFSET < 0 THEN OFFSET = OFFSET AND &HFF 16210 OBJLEN = OBJLEN + 1 16220 OBJ(OBJLEN) = OFFSET 16230 RETURN 16240 '16 bit disp. 16250 OBJ(OBJLEN) = OBJ(OBJLEN) + 128 'set mod field 16260 OBJLEN = OBJLEN + 2 16270 'convert to hi/low form 16280 NUMLOW = OFFSET: GOSUB 16320 'hi/low 16290 OBJ(OBJLEN-1) = NUMLOW 16300 OBJ(OBJLEN) = NUMHIGH 16310 RETURN 16320 '===================================== 16330 'SUBROUTINE HI/LOW 16340 'Splits 16 bit number in numlow into 2 16350 'byte-sized chunks in numhigh & numlow 16360 '===================================== 16370 H$ = HEX$(NUMLOW) 16380 H$ = STRING$(4-LEN(H$),"0") + H$ 16390 NUMLOW = VAL("&H" + RIGHT$(H$,2)) 16400 NUMHIGH = VAL("&H" + LEFT$(H$,2)) 16410 RETURN 16420 '================================= 16430 'SUBROUTINE BUILD_DISP8 16440 'Builds displacement byte. Prints 16450 'error msg if disp. exceeds 127 16460 '================================= 16470 'calc disp. 16480 D = DVAL1 - LOCTR 16490 'check size 16500 IF ABS(D) < 128 THEN 16530 16510 D = 0 16520 IF PASS = 2 THEN MSG$ = "Too far for short jump": GOSUB 18920 16530 'if neg. crunch to 8 bits 16540 IF D < 0 THEN D = D AND &HFF 16550 'build obj. code 16560 OBJLEN = OBJLEN + 1 16570 OBJ(OBJLEN) = D 16580 RETURN 16590 '======================== 16600 'SUBROUTINE BUILD_DISP16 16610 'Builds displacement word 16620 '======================== 16630 'calc disp. 16640 D = DVAL1 - LOCTR 16650 IF OP$ = "JMP" AND (D < 128 AND D > -129) THEN DIAGFLAG = TRUE: MSG$ = "Could use JMPS": GOSUB 18920 16660 'build obj. code 16670 NUMLOW = D: GOSUB 16320 'hi/low 16680 OBJLEN = OBJLEN + 2 16690 OBJ(OBJLEN-1) = NUMLOW 16700 OBJ(OBJLEN) = NUMHIGH 16710 RETURN 16720 '============================ 16730 'SUBROUTINE BUILD_IMMED16 16740 'Builds word(s) of immed data 16750 '============================ 16760 IF DTYPE AND IMMED16 THEN IVAL = DVAL1: GOSUB 16790 16770 IF STYPE AND IMMED16 THEN IVAL = SVAL1: GOSUB 16790 16780 RETURN 16790 'subroutine immed16 16800 NUMLOW = IVAL: GOSUB 16320 'hi/low 16810 OBJLEN = OBJLEN + 2 16820 OBJ(OBJLEN-1) = NUMLOW 16830 OBJ(OBJLEN) = NUMHIGH 16840 RETURN 16850 '========================= 16860 'SUBROUTINE BUILD_IMMED8 16870 'Builds byte of immed data 16880 '========================= 16890 IF DTYPE AND IMMED8 THEN IVAL = DVAL1: GOSUB 16920 16900 IF STYPE AND IMMED8 THEN IVAL = SVAL1: GOSUB 16920 16910 RETURN 16920 'sub. immed8 16930 OBJLEN = OBJLEN + 1 16940 OBJ(OBJLEN) = IVAL 16950 RETURN 16960 '====================== 16970 'SUBROUTINE MEMREF 16980 'Builds a mem addr word 16990 '====================== 17000 'get addr in hi/low form 17010 IF DTYPE = MEM THEN NUMLOW = DVAL1 ELSE NUMLOW = SVAL1 17020 GOSUB 16320 17030 'build word 17040 OBJLEN = OBJLEN + 2 17050 OBJ(OBJLEN-1) = NUMLOW 17060 OBJ(OBJLEN) = NUMHIGH 17070 RETURN 17080 '============== 17090 'SUBROUTINE EQU 17100 '============== 17110 IF (LABEL$ <> "") THEN 17140 17120 IF PASS = 2 THEN MSG$ = "EQU without symbol": GOSUB 18920 17130 RETURN 17140 IF PASS = 2 THEN 17200 17150 IF DTYPE <> (NEAR OR MEM) THEN 17180 'pass 1 default 17160 MSG$ = "EQU with forward reference": GOSUB 18920 17170 RETURN 17180 VAL1(NUMSYM) = DVAL1 17190 SYMTYPE(NUMSYM) = DTYPE 17200 RETURN 17210 '============== 17220 'SUBROUTINE ORG 17230 '============== 17240 'reset loctr 17250 LOCTR = DVAL1 17260 RETURN 17270 '============= 17280 'SUBROUTINE DB 17290 '============= 17300 IF PASS = 2 THEN 17330 17310 'label? set type to mem 17320 IF LABEL$ <> "" THEN SYMTYPE(NUMSYM) = MEM 17330 'scan, building obj. code 17340 LINEPTR = OPDPTR: LINEPTR2 = OPDPTR 17350 WHILE LINEPTR < ENDPTR 17360 'get operand 17370 GOSUB 11260 'get_field 17380 IF NOT FOUND THEN 17540 'exit 17390 'branch for byte or string 17400 TARGET$ = FLD$: GOSUB 13230 'test_number 17410 IF NOT FOUND OR (NUMTYPE AND IMMED8) = FALSE THEN 17440 17420 GOSUB 17560 'build_byte 17430 GOTO 17530 17440 GOSUB 11890 'operand lookup 17450 IF (NOT FOUND) OR ((SYMTYPE(TABLEPTR) AND IMMED8) = FALSE) THEN 17480 17460 NUMVAL = VAL1(TABLEPTR): GOSUB 17560 17470 GOTO 17530 17480 IF LEFT$(FLD$,1) <> "'" THEN 17510 17490 GOSUB 17600 'build_stg 17500 GOTO 17530 17510 'not byte or string? pass 2 error 17520 IF PASS = 2 THEN MSG$ = "Unrecognized operand "+FLD$: GOSUB 18920 17530 WEND 17540 LOCTR = LOCTR + OBJLEN 17550 RETURN 17560 'subroutine build_byte 17570 OBJLEN = OBJLEN + 1 17580 OBJ(OBJLEN) = NUMVAL 17590 RETURN 17600 'subroutine build_stg 17610 FLD$ = MID$(FLD$,2,LEN(FLD$)-2) 'strip off 's 17620 FOR I = 1 TO LEN(FLD$) 17630 OBJLEN = OBJLEN + 1 17640 OBJ(OBJLEN) = ASC(MID$(FLD$,I,1)) 17650 NEXT I 17660 RETURN 17670 '============= 17680 'SUBROUTINE DS 17690 '============= 17700 DSFLAG = TRUE 'signal a ds 17710 IF PASS = 2 THEN 17740 'skip type setting? 17720 'label? 17730 IF LABEL$ <> "" THEN SYMTYPE(NUMSYM) = MEM 17740 'output code 17750 IF STYPE AND IMMED8 THEN DSVAL = SVAL1 ELSE DSVAL = 0 17760 'pass 2, generate obj. code directly 17770 IF PASS = 1 THEN 17810 17780 FOR I = 1 TO DVAL1 17790 LSET BYTE$ = CHR$(DSVAL): PUT #3 17800 NEXT I 17810 LOCTR = LOCTR + DVAL1: BYTESGEN = BYTESGEN + DVAL1 17820 RETURN 17830 '=============== 17840 'SUBROUTINE PROC 17850 '=============== 17860 IF STKTOP < MAXSTK THEN 17890 17870 IF PASS = 2 THEN MSG$ = "Procedures nested too deeply": GOSUB 18920 17880 RETURN 17890 'push new proc type 17900 STKTOP = STKTOP + 1 17910 PROCTYPE(STKTOP) = DTYPE 17920 RETURN 17930 '=============== 17940 'SUBROUTINE ENDP 17950 '=============== 17960 IF STKTOP > 0 THEN 17990 17970 IF PASS = 2 THEN MSG$ = "ENDP without PROC": GOSUB 18920 17980 RETURN 17990 STKTOP = STKTOP - 1 18000 RETURN 18010 '================ 18020 'SUBROUTINE BSAVE 18030 '================ 18040 BASCODE = TRUE 18050 RETURN 18060 '================ 18070 'SUBROUTINE EJECT 18080 '================ 18090 IF PASS = 1 THEN RETURN 18100 LINESUSED = LINENUM + DIAG + ERRS + XTRA 18110 PAGEPOS = LINESUSED MOD PAGELEN 18120 GOSUB 18620 18130 RETURN 18140 '================================ 18150 'SUBROUTINE OUTPUT 18160 'Outputs obj code & listing line, 18170 'given code in obj(objlength) 18180 '================================ 18190 'update # of bytes generated 18200 BYTESGEN = BYTESGEN + OBJLEN 18210 IF DSFLAG THEN H$ = HEX$(LOCTR-DVAL1) ELSE H$ = HEX$(LOCTR-OBJLEN) 18220 H$ = STRING$(4-LEN(H$),"0") + H$ 18230 PRINT#2, TAB(1) H$; 18240 'first 6 bytes 18250 I = 1 18260 PRINT#2, TAB(6) 18270 WHILE I <= 6 18280 IF I > OBJLEN THEN 18350 18290 LSET BYTE$ = CHR$(OBJ(I)): PUT #3 18300 H$ = HEX$(OBJ(I)): IF LEN(H$) = 1 THEN H$ = "0" + H$ 18310 PRINT#2, H$; 18320 I = I + 1 18330 WEND 18340 ' 18350 'source (truncate?) 18360 PRINT#2, TAB(19) 18370 PRINT#2, USING "####"; LINENUM; 18380 PRINT#2, SPACE$(2) LEFT$(INPLINE$, LWIDTH-26) 18390 ' 18400 'formfeed? 18410 GOSUB 18530 18420 ' 18430 'rest of obj. code 18440 WHILE I <= OBJLEN 18450 IF I MOD 6 = 1 THEN PRINT#2, TAB(6): XTRA = XTRA + 1: GOSUB 18530 18460 LSET BYTE$ = CHR$(OBJ(I)): PUT #3 18470 H$ = HEX$(OBJ(I)): IF LEN(H$) = 1 THEN H$ = "0" + H$ 18480 PRINT#2, H$; 18490 I = I + 1 18500 WEND 18510 IF OBJLEN > 6 THEN PRINT#2,: XTRA = XTRA + 1: GOSUB 18530 18520 RETURN 18530 '===================== 18540 'SUBROUTINE NEEDEJECT? 18550 '===================== 18560 IF L$ <> "lpt1:" THEN RETURN 18570 ' 18580 LINESUSED = LINENUM + DIAG + ERRS + XTRA 18590 PAGEPOS = LINESUSED MOD PAGELEN 18600 IF PAGEPOS > MAXLINES THEN GOSUB 18620 18610 RETURN 18620 '================================ 18630 'SUBROUTINE FORMFEED 18640 'Advances to new print page given 18650 'current position in PAGEPOS 18660 '================================ 18670 IF L$ <> "lpt1:" THEN RETURN 18680 FOR I = 1 TO (PAGELEN - PAGEPOS) 18690 PRINT#2, 18700 NEXT I 18710 XTRA = XTRA + PAGELEN - PAGEPOS 18720 RETURN 18730 '======================= 18740 'SUBROUTINE PASSTWO_INIT 18750 '======================= 18760 CLOSE 1: OPEN SC$ FOR INPUT AS 1 18770 ' 18780 IF NOT BASCODE THEN 18870 18790 'build bsave header 18800 LSET BYTE$ = CHR$(253): PUT 3 18810 FOR I = 1 TO 4 18820 LSET BYTE$ = CHR$(0): PUT 3 18830 NEXT I 18840 NUMLOW = LOCTR: GOSUB 16320 'hi/low 18850 LSET BYTE$ = CHR$(NUMLOW): PUT 3 18860 LSET BYTE$ = CHR$(NUMHIGH): PUT 3 18870 PASS = 2 18880 LOCTR = 256 18890 TOTALINES = LINENUM: LINENUM = 0 18900 BYTESGEN = 0 18910 RETURN 18920 '===================== 18930 'SUBROUTINE ERRMSG 18940 'Prints error & diag messages 18950 '===================== 18960 IF AUDIO THEN BEEP 18970 IF DIAGFLAG = TRUE THEN DIAG = DIAG + 1: PRINT#2, "****Diagnostic: "; ELSE ERRS = ERRS + 1: PRINT#2, "****"; 18980 PRINT #2, MSG$;: IF PASS = 1 THEN PRINT#2, " in"; LINENUM ELSE PRINT#2, 18990 DIAGFLAG = FALSE: RETURN 19000 '==================== 19010 'SUBROUTINE FINALPROC 19020 '==================== 19030 IF STKTOP > 0 THEN MSG$ = "Error: missing ENDP": GOSUB 18920 19040 PRINT#2,: PRINT#2,: PRINT#2, ERRS; "Error(s) detected" 19050 XTRA = XTRA + 3: GOSUB 18530 'page eject? 19060 PRINT#2, DIAG; "Diagnostic(s) offered": XTRA = XTRA + 1: GOSUB 18530 19070 PRINT#2,: PRINT#2, BYTESGEN; "Bytes of object code generated" 19080 XTRA = XTRA + 2: GOSUB 18530 19090 'dump sym table 19100 GOSUB 19200 19110 'reset printer 19120 IF L$ = "lpt1:" THEN PRINT#2, PMODEOFF$ 19130 'hang onto scrn listing 19140 IF L$ <> "scrn:" THEN 19190 19150 LOCATE 25,1: BEEP: COLOR BG,FG 19160 PRINT TAB(30) "Hit any key to exit" TAB(79); 19170 C$ = INKEY$: IF C$ = "" THEN 19170 19180 COLOR FG,BG 19190 RETURN 19200 '========================= 19210 'SUBROUTINE DUMP_SYM_TABLE 19220 '========================= 19230 IF NUMSYM = PREDEF THEN RETURN 19240 PRINT#2,: PRINT#2, "SYMBOL TABLE DUMP:": XTRA = XTRA + 2: GOSUB 18530 19250 I = PREDEF + 1 19260 F$ = "\ \!\ \\ \" 'format 19270 PERLINE = LWIDTH \ LEN(F$) 19280 WHILE I <= NUMSYM 19290 H$ = HEX$(VAL1(I)): H$ = STRING$(4-LEN(H$),"0") + H$ 19300 PRINT#2, USING F$; SYM$(I); " "; H$; " "; 19310 I = I + 1 19320 IF (I - PREDEF) MOD PERLINE <> 1 THEN 19340 19330 PRINT#2,: XTRA = XTRA + 1: GOSUB 18530 19340 WEND 19350 PRINT#2,: XTRA = XTRA + 1: GOSUB 18530 19360 RETURN 19370 '========================= 19380 'SUBROUTINE PROGESS REPORT 19390 '========================= 19400 X = POS(0): Y = CSRLIN: LOCATE 25,1: COLOR BG,FG 19410 PRINT "Errors: "; ERRS TAB(25) "Pass "; 19420 IF PASS = 1 THEN PRINT "ONE"; ELSE PRINT "TWO"; 19430 PRINT " in progress."; 19440 IF PASS = 1 THEN PRINT TAB(59) "Lines processed:"; LINENUM; ELSE PRINT TAB(51) "Lines processed:"; LINENUM; "of"; TOTALINES; 19450 PRINT TAB(80);: COLOR FG,BG: LOCATE Y,X 19460 RETURN 19470 '====================== 19480 'SUBROUTINE FINISH_INIT 19490 '====================== 19500 GOSUB 19530 'sym table 19510 GOSUB 19630 'header 19520 RETURN 19530 '======================= 19540 'SUBROUTINE SYMBOL_TABLE 19550 'Sets up sym table 19560 '======================= 19570 FOR I = 1 TO PREDEF 'pre-defined 19580 INPUT#3, SYM$(I), VAL1(I), VAL2(I), SYMTYPE(I) 19590 NEXT I 19600 NUMSYM = PREDEF 19610 CLOSE 3 19620 RETURN 19630 '================= 19640 'SUBROUTINE HEADER 19650 '================= 19660 'printer set up? 19670 IF L$ <> "lpt1:" OR PMODEON$ = "" THEN 19700 19680 PRINT#2, PMODEON$; 19690 WIDTH#2, 132: LWIDTH = 131 19700 'title & date 19710 D$ = LEFT$(DATE$,2) + "/" + MID$(DATE$,4,2) + "/" + RIGHT$(DATE$,2) 19720 PRINT#2, SC$ TAB(LWIDTH-LEN(D$)) D$:PRINT#2,:PRINT#2, 19730 'column headings 19740 PRINT#2,"LOC"TAB(6)"OBJ"TAB(19)"LINE"TAB(25)"SOURCE":PRINT#2, 19750 'used 4 lines 19760 XTRA = XTRA + 4 19770 RETURN 50000 '============================= 50010 'SUBROUTINE INIT 50020 'Initializes all but sym table 50030 '============================= 50040 ERRS = 0: DIAG = 0 50050 'configure 50060 GOSUB 50160 50070 'title page 50080 GOSUB 50660 50090 'constants 50100 GOSUB 50900 50110 'files 50120 GOSUB 51050 50130 'op table 50140 GOSUB 51560 50150 RETURN 50160 '================= 50170 'SUBROUTINE CONFIG 50180 'Reads CHASM.CFG 50190 '================= 50200 'defaults: 50210 PMODEON$ = "": PMODEOFF$ = "": LWIDTH = 79: AUDIO = 1 50220 FG = 7: BG = 0: MAXLINES = 58: PAGELEN = 66 50230 ON ERROR GOTO 50490 50240 OPEN "chasm.cfg" FOR INPUT AS 3 50250 ' 50260 WHILE NOT EOF(3) 50270 INPUT#3, C$ 50280 IF C$ <> "/80" THEN 50300 50290 GOSUB 50590: PMODEOFF$ = CTL$ 'get ctl$ 50300 IF C$ <> "/132" THEN 50320 50310 GOSUB 50590: PMODEON$ = CTL$ 'get ctl$ 50320 IF C$ <> "/LINES" AND C$ <> "/lines" THEN 50340 50330 INPUT#3, MAXLINES 50340 IF C$ <> "/PAGELEN" AND C$ <> "/pagelen" THEN 50360 50350 INPUT#3, PAGELEN 50360 IF C$ <> "/FG" AND C$ <> "/fg" THEN 50380 50370 INPUT#3, FG 50380 IF C$ <> "/BG" AND C$ <> "/bg" THEN 50400 50390 INPUT#3, BG 50400 IF C$ <> "/BEEP" AND C$ <> "/beep" THEN 50430 50410 INPUT#3, AUDIO 50420 IF OVERRAN THEN OVERRAN = FALSE: GOTO 50280 50430 WEND 50440 CLOSE #3 50450 'config screen 50460 SCREEN 0,0,0: WIDTH 80: COLOR FG,BG: KEY OFF: CLS 50470 ON ERROR GOTO 0 50480 RETURN 50490 IF ERL = 50240 THEN 50570 50500 BEEP: COLOR FG,BG: CLS: COLOR BG,FG: LOCATE 12,25 50510 PRINT "Problem with CHASM.CFG" 50520 COLOR FG,BG: LOCATE 24,15 50530 PRINT "Hit Esc to exit, anything else to continue..."; 50540 I$ = INKEY$: IF I$ = "" THEN 50540 50550 IF I$ = CHR$(27) THEN SYSTEM 50560 CLS 50570 RESUME 50460 50580 ' 50590 OVERRAN = FALSE: CTL$ = "": INPUT#3, C$ 50600 WHILE (NOT EOF(3)) AND (LEFT$(C$,1) <> "/") 50610 CTL$ = CTL$ + CHR$(VAL(C$)) 50620 INPUT#3, C$ 50630 WEND 50640 IF EOF(3) THEN CTL$ = CTL$ + CHR$(VAL(C$)) ELSE OVERRAN = TRUE 50650 RETURN 50660 '================ 50670 'SUBROUTINE TITLE 50680 '================ 50690 CLS: LOCATE 24,1,0 50700 PRINT TAB(12)"KEY";STRING$(56,"THEN");"CLOSE 50710 PRINT TAB(12)"OPEN"TAB(69)"OPEN 50720 PRINT TAB(12)"OPEN"TAB(32)"CHASM version 2.10"TAB(69)"OPEN 50730 PRINT TAB(12)"OPEN"TAB(69)"OPEN 50740 PRINT TAB(12)"OPEN"TAB(25)"Cheap Assembler for the IBM PC"TAB(69)"OPEN 50750 PRINT TAB(12)"OPEN"TAB(69)"OPEN 50760 PRINT TAB(12)"OPEN If you have used this program and found it of OPEN 50770 PRINT TAB(12)"OPEN value, your $20 contribution will be appreciated. OPEN 50780 PRINT TAB(12)"OPEN"TAB(69)"OPEN 50790 PRINT TAB(12)"OPEN"TAB(29)"David Whitman"TAB(69)"OPEN 50800 PRINT TAB(12)"OPEN"TAB(29)"2 N Park St."TAB(69)"OPEN 50810 PRINT TAB(12)"OPEN"TAB(29)"Apartment L"TAB(69)"OPEN 50820 PRINT TAB(12)"OPEN"TAB(29)"Hanover, NH 03755"TAB(69)"OPEN 50830 PRINT TAB(12)"OPEN"TAB(69)"OPEN 50840 PRINT TAB(12)"OPEN You are encouraged to copy and share this program. OPEN 50850 PRINT TAB(12)"OPEN"TAB(69)"OPEN 50860 PRINT TAB(12)"SCREEN";STRING$(56,"THEN");"LOAD":PRINT 50870 PRINT TAB(27) "Hit any key to continue...":PRINT:PRINT 50880 I$ = INKEY$: IF I$ = "" THEN 50880 50890 CLS: RETURN 50900 '==================== 50910 'SUBROUTINE CONSTANTS 50920 '==================== 50930 'general 50940 TRUE = -1: FALSE = 0: DELIM$ = " ," 50950 'flag values 50960 'bits 3-5 reserved for ext. values 50970 MACHOP = 1: AUTOW = 4: ADDREG = 64: NEEDEXT = 128 50980 NEEDISP8 = 256: NEEDISP16 = 512: NEEDMODEBYTE = 1024: NEEDIMMED8 = 2048 50990 NEEDIMMED = 4096: DIRECTION = 8192: NEEDMEM = 16384: AUTOC = &H8000 51000 'operand types 51010 ACUM8 = 1: ACUM16 = 2: REG8 = 4: REG16 = 8: MEMREG = 16: CS = 32 51020 SEGR = 64: MEM = 128: IMMED8 = 256: IMMED16 = 512: NONE = 1024 51030 STRING = 2048: NEAR = 4096: FAR = 8192: CL = 16384 51040 RETURN 51050 '====================== 51060 'SUBROUTINE OPEN_FILES 51070 'Gets & opens i/o files 51080 '====================== 51090 ON ERROR GOTO 51370 51100 'input file 51110 LOCATE 1,1: INPUT"Source code file name? [.asm] ", S$ 51120 IF S$ = "" THEN BEEP: GOTO 51110 51130 'no ext, add default 51140 IF INSTR(S$,".") = 0 THEN SC$ = S$ + ".asm" ELSE SC$ = S$: S$ = LEFT$(S$,INSTR(S$,".")-1) 51150 OPEN SC$ FOR INPUT AS #1 51160 LOCATE 3,1 51170 INPUT"Direct listing to Printer (P), Screen (S), or Disk (D)?",L$ 51180 IF L$ = "" THEN BEEP: GOTO 51160 51190 IF INSTR("PpSsDd",L$) = 0 THEN BEEP: GOTO 51160 'invalid response 51200 IF L$ = "P" OR L$ = "p" THEN L$ = "lpt1:" : GOTO 51260 51210 IF L$ = "S" OR L$ = "s" THEN L$ = "scrn:" : GOTO 51260 51220 LOCATE 3,1: PRINT SPACE$(79);: LOCATE 3,1 51230 PRINT"Name for listing file? [";S$;".lst] "; 51240 INPUT "",L$ 51250 IF L$ = "" THEN L$ = S$ + ".lst" 51260 OPEN L$ FOR OUTPUT AS 2 51270 PRINT#2, 'test printer 51280 'obj file 51290 LOCATE 5,1: PRINT "Name for object file? [";S$;".com] "; 51300 INPUT "",O$ 51310 'default: 51320 IF O$ = "" THEN O$ = S$ + ".com" 51330 'open later 51340 ON ERROR GOTO 0 51350 PRINT: PRINT: PRINT 51360 RETURN 51370 '============= 51380 'Error Handler 51390 '============= 51400 IF ERR = 53 THEN 51420 51410 IF NOT((ERR = 52) AND (ERL = 51150)) THEN 51490 51420 COLOR BG,FG: BEEP 51430 PRINT SC$;" not found. Press Esc to exit, anything else to continue."; 51440 SC$ = INKEY$: IF SC$ = "" THEN 51440 51450 IF SC$ = CHR$(27) THEN SYSTEM 51460 LOCATE ,1: COLOR FG,BG: PRINT TAB(80); 51470 LOCATE 1,31: PRINT TAB(80); : LOCATE ,1: RESUME 51110 51480 ' 51490 IF ERL <> 51270 THEN 51550 51500 CLOSE #2: COLOR BG,FG: BEEP 51510 PRINT"Printer not available. Press any key to continue."; 51520 L$ = INKEY$ : IF L$ = "" THEN 51520 51530 LOCATE ,1: COLOR FG,BG: PRINT TAB(80); 51540 LOCATE 3,56: PRINT TAB(80);: LOCATE ,1: RESUME 51170 51550 ON ERROR GOTO 0 51560 '=================== 51570 'SUBROUTINE OP_TABLE 51580 '=================== 51590 X = POS(0): Y = CSRLIN: LOCATE 25,1: COLOR BG+16,FG 51600 PRINT TAB(30) "*Set-up in progress*" TAB(80); 51610 COLOR FG,BG: LOCATE Y,X 51620 OPEN "chasm.dat" FOR INPUT AS 3 51630 FOR I = 1 TO NUMOP 51640 INPUT#3, OPCODE$(I),OPVAL(I),DSTTYPE(I),SRCTYPE(I),OFLAG(I) 51650 NEXT I 51660 RETURN